home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
MONITOR
/
HERCAP10.ARJ
/
CHR2TIFF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-01-13
|
9KB
|
243 lines
Program chr2tiff;
{ liest eine Datei ein, die Blanks und Nicht-Blanks (für gesetzte/nicht }
{ gesetzte Pixel) enthält, und wandelt sie in TIFF-Format um. }
{ Zur Zeit nur einfarbige Bilder, ohne Datenkompression. }
{ Die erste Zeile muß Zeilenlänge und Zeilenzahl (in Pixel) enthalten. }
{ TapirSoft Gisbert W.Selke, 13 Jan 1991 }
{$A+,B-,D+,E+,F-,I-,L+,N-,O-,R+,S+,V- }
{$M 65520,0,480000 }
Uses Crt;
Const progname = 'CHR2TIFF';
version = '1.0';
copyright = 'Freeware by TapirSoft Gisbert W.Selke, Jan 1991';
descript : string = 'Converted from text file'#0;
make : string = 'TapirSoft Gisbert W.Selke'#0;
bufsize = 30000;
nifd = 13;
Tab = $09;
LF = $0A;
CR = $0D;
Return : char= #13;
CtrlZ = $1A;
Blank = $20;
IgnoreSet : Set Of byte = [LF, CR, CtrlZ];
Digits : Set Of byte = [Ord('0')..Ord('9')];
Type iobuf = Array [1..bufsize] Of byte;
tiffheader = Record
format : word;
version : word;
ifdoffset : longint;
ntags : word;
End;
ifdentry = Record
tag : word;
typ : word;
length : longint;
longdata : longint;
End;
Var inf, outf : File;
inbuf, outbuf : iobuf;
tiffhdr : tiffheader;
ifd : Array [1..nifd] Of ifdentry;
endhdr, npix, nrows, inbufct, inct, outbufct : word;
ires, i, k, bitct : word;
l, b : byte;
zend : boolean;
Procedure abort(msg : string; icode : byte);
{ gibt Fehlermeldung aus und stirbt dahin }
Begin { abort }
If IOResult <> 0 Then;
writeln(progname,': ',msg);
Halt(icode);
End; { abort }
Procedure writehdr;
{ schreibt TIFF-Header und wichtige Tags }
Var software : string;
Procedure fillhdr;
{ füllt Header mit den wichtigsten Angaben }
Var i : byte;
hdrsize : word;
Begin { fillhdr }
hdrsize := SizeOf(tiffhdr) + SizeOf(ifd) + SizeOf(endhdr);
software := progname + ' ' + version + #0;
tiffhdr.format := $4949; { byte order : intel }
tiffhdr.version := 42; { version # }
tiffhdr.ifdoffset := 8; { length of first part of header }
tiffhdr.ntags := 13; { number of tags to come }
For i := 1 To tiffhdr.ntags Do
Begin
Case i Of
1 : ifd[i].tag := $FF; { sub file }
2 : ifd[i].tag := $100; { image width }
3 : ifd[i].tag := $101; { image height }
4 : ifd[i].tag := $102; { bits per sample }
5 : ifd[i].tag := $103; { no compression }
6 : ifd[i].tag := $106; { 0 is code for black }
7 : ifd[i].tag := $10E; { where do we come from }
8 : ifd[i].tag := $10F; { vanity }
9 : ifd[i].tag := $111; { strip offset }
10 : ifd[i].tag := $115; { samples per pixel }
11 : ifd[i].tag := $117; { strip byte count }
12 : ifd[i].tag := $11C; { planar configuration }
13 : ifd[i].tag := $131; { more vanity }
End;
ifd[i].typ := 3;
ifd[i].length := 1;
ifd[i].longdata := 1;
End;
ifd[2].longdata := npix;
ifd[3].longdata := nrows;
ifd[6].longdata := 1;
ifd[7].typ := 2;
ifd[7].length := Length(descript); { file description }
ifd[7].longdata := hdrsize;
ifd[8].typ := 2;
ifd[8].length := Length(make);
ifd[8].longdata := hdrsize + Length(descript);
ifd[9].typ := 4;
ifd[9].longdata := hdrsize + Length(descript) + Length(make) +
Length(software);
ifd[11].typ := 4;
ifd[11].longdata := nrows * ((npix+7) Div 8);
ifd[13].typ := 2;
ifd[13].length := Length(software);
ifd[13].longdata := hdrsize + Length(descript) + Length(make);
endhdr := 0;
End; { fillhdr }
Begin { writehdr }
fillhdr;
Move(tiffhdr,outbuf,SizeOf(tiffhdr));
outbufct := SizeOf(tiffhdr);
Move(ifd,outbuf[Succ(outbufct)],SizeOf(ifd));
outbufct := outbufct + SizeOf(ifd);
Move(endhdr,outbuf[Succ(outbufct)],SizeOf(endhdr));
outbufct := outbufct + SizeOf(endhdr);
Move(descript[1],outbuf[Succ(outbufct)],Length(descript));
outbufct := outbufct + Length(descript);
Move(make[1],outbuf[Succ(outbufct)],Length(make));
outbufct := outbufct + Length(make);
Move(software[1],outbuf[Succ(outbufct)],Length(software));
outbufct := outbufct + Length(software);
End; { writehdr }
Function getbyte(extra : boolean) : byte;
{ liest ein Byte aus dem Datenstroom. Wenn extra=False, dann blockieren }
{ Return, LineFeed, CtrlZ das weitere Einlesen (d.h.: es werden bis zum }
{ nächsten Aufruf mit extra=True nur ' ' zurückgeliefert). }
Begin { getbyte }
If inbufct >= inct Then
Begin
If Not zend Then BlockRead(inf,inbuf,SizeOf(inbuf),inct);
zend := inct = 0;
inbufct := 0;
End;
If zend Then getbyte := Blank
Else
Begin
Inc(inbufct);
If extra Or Not (inbuf[inbufct] In IgnoreSet) Then
getbyte := inbuf[inbufct]
Else
Begin
Dec(inbufct);
getbyte := Blank;
End;
End;
End; { getbyte }
Procedure skipeoln;
{ überspringt Eingabe bis zum nächsten Zeilentrenner }
Begin { skipeoln }
While (getbyte(True) <> LF) And Not zend Do ;
End; { skipeoln }
Function getnumber : word;
{ liest eine Zahl aus dem Puffer }
Var w : longint;
b : byte;
Begin { getnumber }
w := 0;
While (Not (b In Digits)) And (b <> CR) Do b := getbyte(True);
While b In Digits Do
Begin
If b In Digits Then w := 10*w + (b-Ord('0'));
If w >= 65536 Then abort('Fehler beim Lesen der Eingabedatei',2);
b := getbyte(False);
End;
getnumber := w;
End; { getnumber }
Procedure putbyte(Var b : byte);
{ schreibt ein Byte in den Ausgabe-Puffer und diesen ggf. auf Platte }
Begin { putbyte }
If outbufct >= SizeOf(outbuf) Then
Begin
BlockWrite(outf,outbuf,outbufct,ires);
If outbufct <> ires Then abort(
'Fehler beim Schreiben der Ausgabedatei',3);
outbufct := 0;
End;
Inc(outbufct);
outbuf[outbufct] := b;
b := 0;
bitct := 0;
End; { putbyte }
Begin
writeln(progname,' ',version,' ',copyright);
writeln('Einfacher Textdatei-nach-TIFF-Konverter');
Assign(inf,'');
Assign(outf,'');
b := FileMode;
FileMode := 0;
Reset(inf,1);
FileMode := b;
Rewrite(outf,1);
inbufct := Succ(SizeOf(inbuf));
inct := 0;
zend := False;
npix := getnumber;
nrows := getnumber;
If IOResult <> 0 Then abort('Fehler beim Lesen der Eingabedatei, 1. Zeile',2);
If (npix = 0) Or (nrows = 0) Then abort('Größenangaben fehlen',4);
skipeoln;
writehdr;
i := 1;
write('1 von ',nrows,' Zeilen');
While i <= nrows Do
Begin
If (i And $F) = 0 Then write(Return,i);
b := 0;
bitct := 0;
For k := 1 To npix Do
Begin
If getbyte(False) = Blank Then b := (b ShL 1)
Else b := (b ShL 1) Or 1;
Inc(bitct);
If bitct = 8 Then putbyte(b);
End;
If bitct > 0 Then
Begin
b := b ShL (8-bitct);
putbyte(b);
End;
skipeoln;
Inc(i);
End;
write(Return,nrows);
BlockWrite(outf,outbuf,outbufct,ires);
If outbufct <> ires Then abort('Fehler beim Schreiben der Ausgabedatei',3);
Close(inf);
Close(outf);
End.